home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / instruct.em < prev    next >
Lisp/Scheme  |  1993-07-12  |  10KB  |  444 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: instructions.em
  4. ;; Date: Fri Dec  6 00:40:15 1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   List of instructions generated by the compiler
  9. ;;
  10.  
  11.  
  12.  
  13.  
  14.  
  15.       
  16.       
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.       
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.       
  34.       
  35.  
  36.  
  37.  
  38.  
  39.  
  40.       
  41.       
  42.  
  43.  
  44.  
  45.  
  46.  
  47.       
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.       
  59.  
  60.  
  61.  
  62.       
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.       
  72.  
  73.  
  74.  
  75.  
  76.     
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125. (defmodule instruct
  126.   (standard0
  127.    list-fns
  128.    scan-args
  129.  
  130.    i-macros
  131.    )
  132.   ()
  133.   
  134.   ;; Do this with structures in the hope that some 
  135.   ;; optimisation may be possible.
  136.   
  137.   ;; abstract class
  138.   ;; 
  139.  
  140.   (defstruct instruction-info ()
  141.     ((in initarg in
  142.            accessor instruction-in-count)
  143.      (out initarg out
  144.         accessor instruction-out-count)
  145.      (stackop initarg stackop
  146.           initform ()
  147.           accessor instruct-stack-op)
  148.      (branchp initarg branch
  149.           initform nil
  150.           accessor instruction-branchp)
  151.      (sidep initarg side
  152.         initform nil
  153.         accessor instruction-sidep)
  154.      (jumpp initarg jump
  155.         initform nil
  156.         accessor instruction-jumpp)
  157.      (bytecode initarg bytecode
  158.            accessor instruction-bytecode)
  159.      (name initarg name
  160.        accessor instruction-name)
  161.      (nargs initarg nargs
  162.        accessor instruction-nargs)
  163.      (null initform ()
  164.        initarg nullp
  165.        accessor instruction-nullp)
  166.      (argwidth initform ()
  167.            initarg argtypes
  168.            accessor instruction-argtypes)
  169.      (cost-fn initform nil
  170.           initarg cost-fn
  171.           accessor instruct-cost-fn)
  172.      (cost-lit initform 1
  173.            initarg cost
  174.            reader instruct-cost-lit))
  175.     constructor make-instruction
  176.     predicate instruction-p)
  177.   
  178.   (export instruction-in-count instruction-out-count instruction-branchp 
  179.       instruction-sidep instruction-jumpp
  180.       instruction-bytecode  instruction-name 
  181.       instruction-nargs instruction-argtypes)
  182.   (defconstant *no-val* '%%**%%)
  183.  
  184.   (defstruct instruction ()
  185.     ((info initarg info
  186.        accessor i-info)
  187.      (args initarg args
  188.        initform *no-val*
  189.        accessor i-args)
  190.      (prev initform nil
  191.        accessor instruction-prev))
  192.     )
  193.  
  194.  
  195.   (defun i-nargs (x)
  196.     (instruction-nargs (i-info x)))
  197.  
  198.   (defun i-inumber (x)
  199.     (instruction-bytecode (i-info x)))
  200.  
  201.   (defun i-name (x) 
  202.     (instruction-name (i-info x)))
  203.   
  204.   (defun i-arg-ref (x n)
  205.     (vector-ref (i-args x) n))
  206.   
  207.   (defun i-link-data (x)
  208.     (i-arg-ref x 0))
  209.   
  210.   (defun i-arg-list (x)
  211.     (convert (i-args x) pair))
  212.   
  213.   (defun i-cost (i) 
  214.     (let ((inf (i-info i)))
  215.       (if (null (instruct-cost-fn inf))
  216.       (instruct-cost-lit inf)
  217.     ((instruct-cost-fn inf) i))))
  218.  
  219.   (export i-cost)
  220.  
  221.   (defun mk-imaker (name number props)
  222.     (let ((nargs (scan-args 'nargs props 0)))
  223.       (let ((istruct (apply make-instruction
  224.                 'name name 
  225.                 'bytecode number
  226.                 'nargs nargs
  227.                 props)))
  228.     (cons istruct
  229.           (lambda (x)
  230.         (make-instance instruction 'info istruct
  231.                    'args (convert x vector)))))))
  232.   
  233.   (export i-info i-arg-ref i-name i-nargs i-args
  234.       i-inumber mk-imaker i-link-data i-arg-list)
  235.  
  236.  
  237.   (defmethod generic-prin ((x instruction) stream)
  238.     (format stream "$<~a" (i-name x))
  239.     (mapcar (lambda (a) 
  240.           (format stream " ~a" a))
  241.         (convert (i-args x)
  242.              pair))
  243.     (prin ">" stream))
  244.  
  245.   ;; NB. I assume label fn's first arg is the label
  246.   ;; Really do need a nice way of doing this junk...
  247.   (defun instruction-label (x)
  248.     (vector-ref (i-args x) 0))
  249.  
  250.   ((setter setter) instruction-label
  251.    (lambda (x y)
  252.      ((setter vector-ref) (i-args x) 0 y)))
  253.  
  254.   (defun is-label-arg (arg)
  255.     (eq arg 'label))
  256.  
  257.   (defun is-label (i)
  258.     (eq (i-info i) i-label-info))
  259.   
  260.   (defun is-branch-arg (arg)
  261.     (eq arg 'branch))
  262.  
  263.   (defun is-link-arg (arg)
  264.     (eq arg 'link))
  265.  
  266.   (defun is-static-arg (arg)
  267.     (eq arg 'static))
  268.   
  269.   (defun is-null-op (x)
  270.     (instruction-nullp (i-info x)))
  271.  
  272.   (defun instruction-argwidth (i)
  273.     (mapcar argsize
  274.         (instruction-argtypes i)))
  275.  
  276.   (export instruction-label is-label
  277.       is-branch-arg is-label-arg is-link-arg is-static-arg
  278.       is-null-op instruction-argwidth)
  279.   
  280.   (defun argsize (x)
  281.     (if (numberp x)
  282.     x
  283.       (cond ((eq x 'label) 4)
  284.         ((eq x 'static) 4)
  285.         ((eq x 'link) 8)
  286.         ((eq x 'branch) 4)
  287.         (t (error "Unknown size" <clock-tick>)))))
  288.  
  289.   ;; Label abstraction...
  290.   (defconstant lab-counter (mk-counter 0))
  291.   
  292.   (defstruct label ()
  293.     ((lab-id initform (lab-counter)
  294.          reader label-id)
  295.      (installed initform nil
  296.         accessor label-installed)
  297.      (lab-refs initform nil
  298.            initarg refs
  299.            accessor lab-refs))
  300.     constructor (make-label x)
  301.     constructor (make-reffed-label-1 refs))
  302.  
  303.   (defun make-refed-label () (make-reffed-label-1 '(1)))
  304.  
  305.   (defmethod generic-prin ((x label) stream)
  306.     (format stream "#<lab: ~a>" (label-id x)))
  307.   
  308.   (defun add-lab-ref (lab ref)
  309.     ((setter lab-refs) lab (cons ref (lab-refs lab))))
  310.   
  311.   (export make-label add-lab-ref lab-refs make-refed-label)
  312.   
  313.   ;; for inline-assembler....
  314.   
  315.   (defconstant find-instruction (mk-finder))
  316.   (export find-instruction)
  317.  
  318.   (defun add-instruction (x val)
  319.     ((setter find-instruction) x val))
  320.  
  321.   ;; For pre-linked code
  322.   (defstruct inline-code-list ()
  323.     ((count initarg count reader inline-code-count)
  324.      (code initarg code reader inline-code))
  325.     constructor (make-inline-code count code)
  326.     predicate is-inline-code)
  327.   
  328.   (export inline-code-list inline-code-count inline-code make-inline-code
  329.       is-inline-code)
  330.   ;; Each instruction in turn......
  331.   ;; definstruction defines+exports aconstructor named by the instruction, 
  332.   ;; plus <instruction>-info, the relavant info instance
  333.  
  334.   ;; hanging around instructions
  335.   (definstruction nop 0 in 0 out 0)
  336.  
  337.   ;; shoving stuff on the stack
  338.   
  339.   (definstruction push-global 1 nargs 1 in 0 ;; args: module, index as pair
  340.     out 1 argtypes (link) cost 4)
  341.   (definstruction push-special 3 nargs 1 ;; args: name of special
  342.     in 0 out 1 argtypes (1) cost 2) 
  343.   (definstruction push-static 4 nargs 1 in 0 out 1 argtypes (static) cost 2) ;;       reference no.
  344.   (definstruction push-small-fixnum 6 nargs 1 in 0 out 1 argtypes (1) cost 2) 
  345.   (definstruction push-fixnum 5 nargs 1 in 0 out 1 argtypes (4) cost 2) 
  346.   
  347.   (definstruction set-global 7 in 1 out 0 side t argtypes (static) cost 2) ;; args: index 
  348.   ;; Stack reference
  349.   (definstruction nth-ref 8 nargs 1 in 0 out 1 argtypes (1) stackop t)
  350.   (definstruction nth-ref-0 9 in 0 out 1 stackop t)
  351.   (definstruction nth-ref-1 10 in 0 out 1 stackop t)
  352.   (definstruction nth-ref-2 11 in 0 out 1 stackop t)
  353.   (definstruction nth-ref-3 12 in 0 out 1 stackop t)
  354.   (definstruction set-nth 13 nargs 1 in 2 out 0 side t argtypes (1) stackop t)
  355.   ;; stack abuse,  ;; depth of slide, keep
  356.   (definstruction i-slide-stack 14 nargs 2 in arg-1 out arg-2 argtypes (1 1) stackop t)
  357.   (definstruction i-slide-stack-1 15 nargs 1 in arg-1 out 1 argtypes (1) stackop t)
  358.   (definstruction swap 16 in 2 out 2 cost 1 stackop t)
  359.   (definstruction drop 17 nargs 1 in arg-1 out 0 argtypes (1) stackop t) ;; equiv to (slide-stack n 0)
  360.   (definstruction drop-1 18 in arg-1 out 0 stackop t) ;; equiv to (slide-stack 1 0)
  361.   
  362.   ;; Environment hacking --- assumed to be TOS
  363.   (definstruction env-ref 19 nargs 2 in 1 out 1 argtypes (1 1) cost 2) ;; depth, dist
  364.   ;; depth, dist, returns new env
  365.   (definstruction set-env 20 nargs 2 in 2 out 1 side t argtypes (1 1) cost 2)
  366.   (definstruction make-env 22 nargs 1 in 1 out 1 argtypes (1) cost 3) ;; size
  367.   (definstruction pop-env 21 nargs 1 in 1 out 1 argtypes (1) cost 2) ;; how far to drop
  368.  
  369.   ;; Object reference 
  370.   (definstruction vref 23 in 2 out 1 cost 1)
  371.   (definstruction set-vref 24 in 3 out 1 side t cost 2)
  372.   (definstruction slot-ref 25 nargs 1 in 1 out 1 argtypes (1) cost 2)
  373.   (definstruction slot-ref-0 26 in 1 out 1 cost 1)
  374.   (definstruction slot-ref-1 27 in 1 out 1 cost 1)
  375.   (definstruction set-slot 28 nargs 1 in 2 out 1 side t argtypes (1) cost 2)
  376.   (definstruction set-slot-1 29  in 2 out 1 side t cost 2)
  377.  
  378.   (definstruction i-set-type 30 in 1 out 1 side t cost 2)
  379.  
  380.   ;; Branches and jumps
  381.   (definstruction branch 31 nargs 1 in 0 out 0 branch t conditional t argtypes (branch)) ;; local-label
  382.   (definstruction branch-nil 32 nargs 1 in 0 out 0 branch t conditional t argtypes (branch)) ;; local label
  383.  
  384.   ;; Calling functions...
  385.   ;; Would be nice to be able to test for side effects near here
  386.   ;; in nargs+2, out 1
  387.   (definstruction apply-args 63 nargs 0 in 2 out 1 side t )
  388.   (definstruction apply-any 33 nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  389.  
  390.   (definstruction apply-bvf 34 nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  391.   (definstruction apply-cfn 62 nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  392.   (definstruction apply-method-list 61 nargs 0 in 2 out 1 side t)
  393.  
  394.   ;; in nargs+2, out 1
  395.   (definstruction apply-methods 35 nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  396.   (definstruction push-label 36 nargs 1 in 0 out 0 argtypes (branch))            ;; a label
  397.  
  398.   ;; coming back
  399.   ;; We assume that the stack is just (ret val) at this point
  400.  
  401.   (definstruction return 37 nargs 0 in 2 out 1 side t)
  402.   
  403.   ;; Leaving for real 
  404.   (definstruction i-exit 38 nargs 0 in 0 out 0 side t)
  405.  
  406.   ;; Allocation
  407.   (definstruction i-cons 39 in 2 out 1 cost 2)
  408.         ;; args: size -- reads entry from stack        
  409.   (definstruction alloc-closure 40 nargs 1 in 2 out 1 argtypes (1) cost 3) 
  410.   (definstruction alloc-extended-closure 51 nargs 1 in 2 out 1 argtypes (1) cost 3) 
  411.   (definstruction alloc-thing 61 in 1 out 1)
  412.     
  413.   ;; tests
  414.   (definstruction nullp 42 in 1 out 1)
  415.   (definstruction eqp 43 in 2 out 1)
  416.   (definstruction i-consp 44 in 1 out 1)
  417.     
  418.   ;; functions 
  419.   (definstruction i-assq 48 nargs 0 in 2 out 1 cost 2)
  420.   (definstruction i-memq 49 nargs 0 in 2 out 1 cost 2)
  421.   (definstruction i-scanq 50 nargs 0 in 2 out 1 cost 2)
  422.  
  423.   ;; reflection (hacks)
  424.   (definstruction current-context 46 in 0 out 1)
  425.   (definstruction ensure-stack 47 nargs 1 in 0 out 0 argtypes (1))
  426.  
  427.   ;; Need labels here --- essentially this is partially IR+OUTPUT
  428.  
  429.   (definstruction i-label 257 nargs 1 in 0 out 0)
  430.   
  431.   ;; so the output is readable...
  432.   (definstruction dead-code 258 nargs 0 in 0 out 0 nullp t)
  433.     
  434.   ;; User defined types
  435.   ;; from structs.h
  436.  
  437.   (defconstant bc-macro-type #x27)
  438.   (export bc-macro-type)
  439.  
  440.   ;; hack
  441.   ((setter instruct-cost-fn) i-slide-stack-info (lambda (i) (+ (i-arg-ref i 1) 2)))
  442.   ;; end module
  443.   )
  444.